PC-SIG: Games/PC-SIG Games (PC-SIG).iso/749/LOTTERY.PAS

Pascal/Delphi Source File | 1986-11-08 | 50.9 KB | 1,953 lines

{
This program is based on the MD LOTTO.  It was developed as a training
exercise that got out of hand and became a home project for a potentially
salable product.
}


PROGRAM LOTTERY(INPUT,OUTPUT);

{$I-}  {IGNORE I/O ERRORS)
{$R+}  {SET UP RANGE AND BOUNDS CHECKING}
     {GLOBAL CONSTANTS AND TYPES}

CONST
      RELNO = 1.003; {RELEASE NUMBER}
      NUMPIC = 6;
      MAXNUM = 40;
      TKTMAX = 200;

TYPE
      LOTNUMS = 1 .. MAXNUM;
      TKT = ARRAY [1..NUMPIC] OF LOTNUMS;
      TKTAR = ARRAY [1..TKTMAX] OF TKT;
      OPT = (Y,N);
      TICKETRECORD = RECORD TICKET:TKT; END;
      TKTFILE = FILE OF TICKETRECORD;
      FILENAME = STRING[32];
      DIRECTARRAY = ARRAY [1..100] OF FILENAME;
VAR
      WTKT,CTKT                                          : TKT;
      TKTS                                               : TKTAR;
      NUMTKTS, I, J, K, ARRAYSIZE                        : INTEGER;
      WINNERVALID                                        : BOOLEAN;
      PWPRINT, PWDISP, AUTOPRINT, AUTODISP               : OPT;
      TKTREC                                             : TICKETRECORD;
      INFILE, OUTFILE                                    : TKTFILE;
      STARTBYTE, POKEBYTE, NOWBYTE, OLDCON               : BYTE;

CONST {TYPED}
      IOVal    : Integer = 0;
      IOErr    : Boolean = False;

{
     These procedures CHIRP, BEEP, BEEPBEEP, HILOTONE, SIREN, and ALERT1
provide the bells and whistles that are used throughout the program.
}

PROCEDURE CHIRP;

BEGIN
SOUND (500);
DELAY (200);
NOSOUND;
END;


PROCEDURE BEEP;

BEGIN
SOUND(750);
DELAY(250);
NOSOUND;
END {PROC};


PROCEDURE BEEPBEEP(I:INTEGER);

VAR J:INTEGER;

BEGIN
FOR J := 1 TO I DO BEGIN BEEP; DELAY(175); END;
END {PROC};


PROCEDURE HILOTONE(I:INTEGER);

VAR J:INTEGER;

BEGIN
FOR J := 1 TO I DO BEGIN
   SOUND (1000);
   DELAY (500);
   NOSOUND;
   SOUND (500);
   DELAY (500);
   NOSOUND;
END {DO};
END {PROC};


PROCEDURE SIREN(I:INTEGER);

VAR J,K:INTEGER;

BEGIN
FOR J := 1 TO I DO BEGIN
   FOR K := 500  TO     2000 DO BEGIN SOUND(K);DELAY(1);END;
   FOR K := 2000 DOWNTO  500 DO BEGIN SOUND(K);DELAY(1);END;
END {DO};
NOSOUND;
END {PROC};

PROCEDURE YELP(I:INTEGER);

VAR J,K:INTEGER;

BEGIN
FOR J := 1 TO I DO BEGIN
   FOR K := 1 TO 500 DO BEGIN SOUND(2000 - (3 * K));DELAY(1);END;
   FOR K := 1 TO 500 DO BEGIN SOUND(2000 - (3 * K));DELAY(1);END;
END {DO};
NOSOUND;
END {PROC};


PROCEDURE ALERT1(I:INTEGER);

VAR J,K:INTEGER;

BEGIN
FOR J := 1 TO I DO BEGIN
   FOR K := 1 TO 500 DO BEGIN SOUND(500 + (3 * K));DELAY(1);END;
   FOR K := 1 TO 500 DO BEGIN SOUND(500 + (3 * K));DELAY(1);END;
END {DO};
NOSOUND;
END {PROC};


PROCEDURE HILITE;

BEGIN
TEXTCOLOR (YELLOW);
TEXTBACKGROUND (BLACK);
END;


PROCEDURE LOLITE;

BEGIN
TEXTCOLOR (YELLOW);
TEXTBACKGROUND (BLUE);
END;


PROCEDURE SCRNRESET; {GENERAL SCREEN RESET YELLOW ON BLUE}

BEGIN
WINDOW(1,1,80,25);
TEXTCOLOR (YELLOW);
TEXTBACKGROUND (BLUE);
CLRSCR;
END {PROC};

{ *** RANDOMIZE, IOCHECK AND DOS DIRECTORY CALL PROCEDURES ADAPTED FROM
      TURBO PASCAL 2.0 WITH PERMISSION OF BORLAND INTERNATIONAL AS
      STATED IN THEIR DOCUMENTATION
      }

procedure IOCheckA;
{
       This routine sets IOErr equal to IOresult, then sets
       IOFlag accordingly.  It is a subset of routine IOCHECK.
}
var
  Ch                   : Char;
begin
  IOVal := IOresult;
  IOErr := (IOVal <> 0);
end {proc};


procedure IOCheck;
{
       This routine sets IOErr equal to IOresult, then sets
       IOFlag accordingly.  It also prints out a message on
       the 25th line of the screen, then waits for the user
       to hit any character before proceding.
}
var
  Ch                   : Char;
begin
  IOVal := IOresult;
  IOErr := (IOVal <> 0);
  if IOErr then begin
    GoToXY(1,25); ClrEol; {CLEAR ANYTHING ON LINE 25}
    BEEPBEEP(2);
    case IOVal of
      $01  :  Write('File does not exist');
      $02  :  Write('File not open for input');
      $03  :  Write('File not open for output');
      $04  :  Write('File not open');
      $05  :  Write('Can''t read from this file');
      $06  :  Write('Can''t write to this file');
      $10  :  Write('Error in numeric format');
      $20  :  Write('Operation not allowed on a logical device');
      $21  :  Write('Not allowed in direct mode');
      $22  :  Write('Assign to standard files not allowed');
      $90  :  Write('Record length mismatch');
      $91  :  Write('Seek beyond end of file');
      $99  :  Write('Unexpected end of file');
      $F0  :  Write('Disk write error');
      $F1  :  Write('Directory is full');
      $F2  :  Write('File size overflow');
      $FF  :  Write('File disappeared')
    else      Write('Unknown I/O error:  ',IOVal:3)
    end{case};
    Read(Kbd,Ch);
    GoToXY(1,25);
    ClrEol;
  end{if};
end; { of proc IOCheck }


{
   Randomize Procedure For MS-DOS & PC-DOS Turbo Pascal

   This new Randomize has two Integer parameters.  If they are both 0, then
the random number seed is set randomly.  If either of the parameters is
nonzero, then they are both stored directly into the 32 bit seed.

   To set the seed randomly (Randomize(0,0)), the procedure calls MS-DOS
to get the current time.  This is a 32 bit value, which is also stored
directly into the seed.  On some systems, (i.e. the NCR Decision Mate V),
the clock does not tick, so the time never changes.  Randomize checks this,
and if the clock hasn't changed after a Delay(100), it asks the user to hit
a key.  While waiting for the key, it continuously increments two counters.
These are then stored into the seed.

{ Please note:  This routine is for MS-Dos/PC-Dos Turbo ONLY! }

procedure Randomize(I,J: Integer);

var
  RSet    : record
              AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags: Integer;
            end;
  Ch      : Char;

begin
  if (I=0) and (J=0) then begin     { Generate a random random number seed }
    RSet.AX:=$2C00;                             { DOS time of day function }
    MSDos(RSet);
    I:=RSet.CX;                           { Set I and J to the system time }
    J:=RSet.DX;
    Delay(100);   { This delay may have to be increased for faster systems }
    MSDos(RSet);
    if (I=RSet.CX) and (J=RSet.DX) then begin        { Clock isn't ticking }
      I := 0;
      J := 0;
      while KeyPressed do
        Read(Kbd,Ch);                              { Clear keyboard buffer }
      Write('Hit any key to set the random number generator: ');
      repeat
        I := I+13;
        J := J+17
      until Keypressed;
      Read(Kbd,Ch);                                 { Absorb the character }
      WriteLn
    end
  end;
  MemW[DSeg:$129]:=I;  { This is the core of the routine: store a 32 bit }
  MemW[DSeg:$12B]:=J;  {  seed at locations DSeg:$0129...DSeg:$012C      }
end; { of procedure Randomize }


PROCEDURE DirList (VAR DirArray  : DirectArray;
                   VAR ArraySize : INTEGER);

{
       This is a simple procedure to build an array of names
       out the directory of the current (logged) drive.
}
type
  Char12arr            = array [ 1..12 ] of Char;
  String20             = string[ 20 ];
  RegRec =
    record
      AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags : Integer;
    end;

var
  Regs                 : RegRec;
  DTA                  : array [ 1..43 ] of Byte;
  Mask                 : Char12arr;
  NamR                 : String20;
  Error, I, KK         : Integer;

begin { main body of procedure DirList }

  ArraySize := 0;
  FOR KK := 1 TO 100 DO DIRARRAY[KK] := '';
  FillChar(DTA,SizeOf(DTA),0);        { Initialize the DTA buffer }
  FillChar(Mask,SizeOf(Mask),0);      { Initialize the mask }
  FillChar(NamR,SizeOf(NamR),0);      { Initialize the file name }

  Regs.AX := $1A00;         { Function used to set the DTA }
  Regs.DS := Seg(DTA);      { store the parameter segment in DS }
  Regs.DX := Ofs(DTA);      {   "    "      "     offset in DX }
  MSDos(Regs);              { Set DTA location }
  Error := 0;
  Mask := '????????.LFD';    { Use global search }
  Regs.AX := $4E00;          { Get first directory entry }
  Regs.DS := Seg(Mask);      { Point to the file Mask }
  Regs.DX := Ofs(Mask);
  Regs.CX := 22;             { Store the option }
  MSDos(Regs);               { Execute MSDos call }
  Error := Regs.AX and $FF;  { Get Error return }
  I := 1;                    { initialize 'I' to the first element }
  if (Error = 0) then BEGIN
    repeat
      NamR[I] := Chr(Mem[Seg(DTA):Ofs(DTA)+29+I]);
      I := I + 1;
    until not (NamR[I-1] in [' '..'~']) or (I>20);

    NamR[0] := Chr(I-1);          { set string length because assigning }
                                  { by element does not set length }
    ArraySize := 1;
    DirArray[ArraySize] := NAMR;
  END{IF};
  while (Error = 0) do begin
    Error := 0;
    Regs.AX := $4F00;           { Function used to get the next }
                                { directory entry }
    Regs.CX := 22;              { Set the file option }
    MSDos( Regs );              { Call MSDos }
    Error := Regs.AX and $FF;   { get the Error return }
    I := 1;
    repeat
      NamR[I] := Chr(Mem[Seg(DTA):Ofs(DTA)+29+I]);
      I := I + 1;
    until not (NamR[I-1] in [' '..'~'] ) or (I > 20);
    NamR[0] := Chr(I-1);
    if (Error = 0) THEN BEGIN
      ArraySize := ArraySize + 1;
      DirArray[ArraySize] := NAMR;
    END {IF};
  end{WHILE};
end{ of procedure DirList  };

{
This procedure outputs the array generated in Dirlist and generates the
user screen display in 6 wide format.
}


PROCEDURE DISPDIR;

LABEL
    EXIT;

VAR
    DIRARRAY                      : DIRECTARRAY;
    ARRAYSIZE, I, J, K, M         : INTEGER;
    CH                            : CHAR;

BEGIN
SCRNRESET;
DIRLIST(DIRARRAY,ARRAYSIZE);
GOTOXY (33,2);
WRITELN ('LIST OF FILES');
WRITELN;
IF ARRAYSIZE < 1 THEN GOTO EXIT;

                  {PRINT 6 WIDE WITHOUT THE .LPD SUFFIX}

I := 1;
J := 6;
REPEAT
  IF J > ARRAYSIZE THEN J := ARRAYSIZE;  {MAKE SURE NOT TO PRINT TOO MANY}
  FOR K := I TO J DO BEGIN
    WHILE ((LENGTH (DIRARRAY[K]) > 0) AND (DIRARRAY[K][1] = ' ')) DO BEGIN
       DELETE (DIRARRAY[K],1,1); {TRIM LEADING BLANKS}
    END {DO};
    WHILE ((LENGTH (DIRARRAY[K]) > 0)
            AND (DIRARRAY[K][LENGTH(DIRARRAY[K])] = ' ')) DO BEGIN
      DELETE (DIRARRAY[K], (LENGTH(DIRARRAY[K])), 1); {TRIM TRAILING BLANKS}
    END {DO};
                    {TRIM TO SHOW FILE NAME ONLY}
    IF LENGTH (DIRARRAY[K]) > 8 THEN DELETE (DIRARRAY[K], 9, 32);
    M := POS ('.',DIRARRAY[K]);
    IF M > 0 THEN DELETE (DIRARRAY[K], M, 8);
    IF K = I THEN
       WRITE (DIRARRAY[K]:15) {WRITE IN A 15 COLUMN FIELD}
    ELSE
       WRITE (DIRARRAY[K]:12) {WRITE IN A 15 COLUMN FIELD}
    {ENDIF};
  END {DO};
  WRITELN;
  I := I + 6; {INCREMENT LINE POINTER}
  J := I + 5;
UNTIL I > ARRAYSIZE;
WRITELN;
WRITELN;
GOTOXY (28,WHEREY);
WRITELN ('PRESS ANY KEY TO CONTINUE');
READ (KBD,CH);
CLRSCR;
EXIT: END {PROC};


{
This procedure initializes the major common variables of the program and
effectively acts as a data reset function.
}

PROCEDURE REINIT;

VAR I, J : INTEGER;

BEGIN
WINNERVALID := FALSE;
NUMTKTS := 0;
FOR I := 1 TO TKTMAX DO FOR J := 1 TO NUMPIC DO TKTS[I,J] := MAXNUM;
FOR I := 1 TO NUMPIC DO WTKT[I] := MAXNUM;
END{PROC};



{
This procedure allows the changing of the print and display options for the
program.

It uses a case procedure to toggle the control variable for each parameter.

A test for value 0 is used for termination and return to the main program.
}

PROCEDURE OPTMENU;

VAR ANSWER : INTEGER;

BEGIN
REPEAT
   SCRNRESET;
   GOTOXY (34,2);
   WRITELN ('OPTIONS MENU');
   GOTOXY (1,5);
   WRITELN ('0.  EXIT MEMU');
   WRITELN;
   IF PWPRINT = Y THEN BEGIN
      WRITELN ('1.  PRINT WINNERS WHEN FOUND   = YES.');END
   ELSE  BEGIN
      WRITELN ('1.  PRINT WINNERS WHEN FOUND   = NO.');
   END{IF};
   IF PWDISP = Y THEN BEGIN
      WRITELN ('2.  DISPLAY WINNERS WHEN FOUND = YES.');END
   ELSE BEGIN
      WRITELN ('2.  DISPLAY WINNERS WHEN FOUND = NO.');
   END{IF};
   WRITELN;
   IF AUTOPRINT = Y THEN BEGIN
      WRITELN ('3.  AUTOPRINT TICKETS   = YES.');END
   ELSE BEGIN
      WRITELN ('3.  AUTOPRINT TICKETS   = NO.');
   END{IF};
   IF AUTODISP = Y THEN BEGIN
      WRITELN ('4.  AUTODISPLAY TICKETS = YES.');END
   ELSE BEGIN
      WRITELN ('4.  AUTODISPLAY TICKETS = NO.');
   END{IF};
   GOTOXY (10,20);
   WRITE ('ENTER SELECTION TO CHANGE.   ');
   ANSWER := 30; {STORE DEFAULT VALUE TO CAUSE RECYCLE}
   READLN (ANSWER);
   IOCHECKA;
   IF IOERR = TRUE THEN ANSWER := 30; {ON ERROR RELOAD INVALID ANSWER}
   CASE ANSWER OF
   0 :  {NO OPERATION};
   1 :  IF PWPRINT = Y THEN PWPRINT := N ELSE PWPRINT := Y;
   2 :  IF PWDISP = Y THEN PWDISP := N ELSE PWDISP := Y;
   3 :  IF AUTOPRINT = Y THEN AUTOPRINT := N ELSE AUTOPRINT := Y;
   4 :  IF AUTODISP = Y THEN AUTODISP := N ELSE AUTODISP := Y;
   ELSE BEEP
END{CASE};
UNTIL ANSWER = 0;
END{PROC};


{
This procedure compares two tickets and keeps track of the number of matches.
As it is called very, very frequently, quick end tests are made to cut the
number of comparisons made to a minimum.  If 3 misses on a ticket are
accumulated, the tickets cannot be matched and the comparison terminates.
Win is set to the number of matches if 4 or more matches occur.  Otherwise
a 0 is returned.
}



PROCEDURE COMPARE(TICK1,TICK2               :TKT;
                  VAR WIN                   :INTEGER);

VAR   POINT1,POINT2,MISS1,MISS2,HIT         :INTEGER;
      DONE                                  :BOOLEAN;

BEGIN
               {INITIALIZE VARIABLES}
POINT1 := 1 ;
POINT2 := 1 ;
WIN    := 0 ;
MISS1  := 0 ;
MISS2  := 0 ;
HIT    := 0 ;

               {BEGIN EXAMINING THE TICKETS FOR A MATCH}

DONE   := FALSE;
REPEAT
  IF (TICK1[POINT1] = TICK2[POINT2]) THEN  {COMPARE NUMBER ON EACH TICKET}
     BEGIN {TRUE}
     HIT := HIT + 1                        {A HIT, TRY FOR 6};
     POINT1 := POINT1 + 1 ;                {INDEXING POINTERS}
     POINT2 := POINT2 + 1 ;
     END {TRUE BRANCH}
  ELSE                                      {A MISS}
     BEGIN {FALSE PATH}
     {INDEX MISS COUNT AND POINTER OF TICKET WITH SMALLEST NUMBER}
     IF (TICK1[POINT1] > TICK2[POINT2]) THEN
        BEGIN {A MISS ON TICKET 2}
        MISS2  := MISS2  + 1 ;
        POINT2 := POINT2 + 1 ;
        END {TICKET 2 MISS}
     ELSE
        BEGIN {MISS ON TICKET 1}
        MISS1  := MISS1  + 1 ;
        POINT1 := POINT1 + 1 ;
        END {TICKET 1 MISS}
     {ENDIF}
     END {FALSE PATH}
  {ENDIF};

  {TEST FOR DONE, 3 MISSES ON A TICKET OR OUT OF NUMBERS TO COMPARE}
  IF ((MISS1 > 2) OR (MISS2 > 2) OR (POINT1 > NUMPIC) OR (POINT2 > NUMPIC))
     THEN DONE := TRUE;
UNTIL (DONE = TRUE);
{TEST AND REPORT A WIN IF OVER 3 HITS}
IF (HIT > 3) THEN WIN := HIT;
END;


{
This procedure will print or display winning tickets based on the option
variables.  A variety of bells and whistles are used to alert various
levels of wins.  If PWDISP and PWPRINT are both N this routine will produce
no output.
}

PROCEDURE PWIN(TKTNO,WINSIZE        :INTEGER;
               PTKT,WTKT            :TKT;
               PWPRINT,PWDISP       :OPT);


VAR  I                              : INTEGER;

BEGIN

HILITE;
CLRSCR;

IF PWDISP = Y THEN {WRITE TO SCREEN}
BEGIN
   WRITELN;
   WRITELN ('   !!!   YOU HAVE A WINNER   !!!   ');
   FOR I := 1 TO 3 DO WRITELN;
   WRITELN ('TICKET NO: ',TKTNO:4,'.');
   WRITELN;
   WRITELN ('WINSIZE:',WINSIZE:4,'.');
   WRITELN;
   WRITE ('PICK Nos:');
   FOR I := 1 TO NUMPIC DO WRITE (PTKT[I]:6);
   WRITELN;
   WRITELN;
   WRITE ('THE LOTTO DRAW WAS:');
   FOR I:= 1 TO NUMPIC DO WRITE (WTKT[I]:6);
   WRITELN;
   WRITELN;
   CASE WINSIZE OF {CELEBRATION WORDS AND MUSIC}
   4 : BEEPBEEP(3);
   5 : BEGIN
          WRITELN ('   !!!   AND IT`S A BIG ONE   !!!');
          YELP(3);
       END;
   6 : BEGIN
          WRITELN ('          !!!  YOU`RE RICH  !!!');
          WRITELN;
          WRITELN ('RICH I TELL YOU!...  RICH RICH RICH !!!!');
          WRITELN;
          WRITELN ('RETIRE NOW, AVOID THE RUSH');
          WRITELN;
          WRITELN ('YOU MAY EXIT THE PROGRAM AND SHUT OFF THE COMPUTER');
          WRITELN;
          WRITELN ('              WHEN YOU WAKE UP');
          SIREN(2);
          DELAY(10);
          YELP(3);
          DELAY(10);
          ALERT1(3);
          DELAY(10);
       END;
   END{CASE};
   GOTOXY(1,25);
   CLREOL;
   WRITE ('PRESS ANY KEY TO CONTINUE');
   REPEAT BEGIN END UNTIL KEYPRESSED;
   READ (KBD);
   CLRSCR;
END {IF};

IF PWPRINT = Y THEN {WRITE TO PRINTER}
BEGIN
   WRITELN (LST);
   WRITELN (LST,'   !!!   YOU HAVE A WINNER   !!!   ');
   FOR I := 1 TO 3 DO WRITELN (LST);
   WRITELN (LST,'TICKET NO: ',TKTNO:4,'.');
   WRITELN (LST);
   WRITELN (LST,'WINSIZE:',WINSIZE:4,'.');
   WRITELN (LST);
   WRITE (LST,'PICK Nos:');
   FOR I := 1 TO NUMPIC DO WRITE (LST,PTKT[I]:6);
   WRITELN (LST);
   WRITELN (LST);
   WRITE (LST,'THE LOTTO DRAW WAS:');
   FOR I:= 1 TO NUMPIC DO WRITE (LST,WTKT[I]:6);
   FOR I := 1 TO 4 DO WRITELN (LST);
   WRITELN (LST);
   WRITELN (LST);
   IF ((PWDISP = N) AND (PWPRINT = Y)) THEN BEGIN { WHEN PRINTING ONLY}
      CASE WINSIZE OF {CELEBRATION WORDS AND MUSIC}
      4 : BEEPBEEP(3);
      5 : BEGIN
             WRITELN (LST,'   !!!   AND IT`S A BIG ONE   !!!');
             YELP(3);
          END;
      6 : BEGIN
             WRITELN (LST,'          !!!  YOU`RE RICH  !!!');
             WRITELN (LST);
             WRITELN (LST,'RICH I TELL YOU!...  RICH RICH RICH !!!!');
             WRITELN (LST);
             WRITELN (LST,'RETIRE NOW, AVOID THE RUSH');
             WRITELN (LST);
             WRITELN (LST,'YOU MAY EXIT THE PROGRAM AND SHUT OFF THE COMPUTER');
             WRITELN (LST,'              WHEN YOU WAKE UP');
             SIREN(2);
             DELAY(10);
             YELP(3);
             DELAY(10);
             ALERT1(3);
             DELAY(10);
          END;
      END{CASE};
   END{IF};
   FOR I := 1 TO 2 DO WRITELN (LST);
END{IF};
END{PROC};

{
This procedure uses the compare procedure to test for winning tickets,
and then calls pwin in case of winners to print out the winners to screen or
printer.  A summary of the tickets scanned is displayed at the end of the
procedure.
}

PROCEDURE SCANTKTS;

VAR
   I, WIN, WIN4, WIN5, WIN6, LOSERS        : INTEGER;
   CTKT                                    : TKT;

BEGIN {PROC}
{INITIALIZE VARIABLES}
WIN4   := 0;
WIN5   := 0;
WIN6   := 0;
LOSERS := 0;
SCRNRESET;
FOR I := 1 TO NUMTKTS DO
    BEGIN {DO}
    CTKT := TKTS[I];                {SELECT A TICKET}
    COMPARE(CTKT,WTKT,WIN);  {COMPARE WITH WINNING NOS.}
    IF (WIN > 3) THEN               {TEST FOR A WINNER, WIN>3}
       BEGIN {TRUE}
       PWIN(I,WIN,CTKT,WTKT,PWPRINT,PWDISP); {PRINT WINNING TICKET}
       CASE WIN OF
          4:   WIN4 := WIN4 + 1;
          5:   WIN5 := WIN5 + 1;
          6:   WIN6 := WIN6 + 1;
       END {CASE}
       END {TRUE}
    ELSE
       LOSERS := LOSERS + 1
    {ENDIF}
END {DO} ;
SCRNRESET;
WINDOW (3,3,77,22);
HILITE;
CLRSCR;
WINDOW (4,3,77,22);
WRITELN;
WRITELN ('THERE WERE ',NUMTKTS,' TICKETS CHECKED.');
WRITELN;
WRITELN ('THERE WERE ',WIN4,' TICKET(S) WITH 4 MATCHING NUMBERS.');
WRITELN;
WRITELN ('THERE WERE ',WIN5,' TICKET(S) WITH 5 MATCHING NUMBERS.');
WRITELN;
WRITELN ('THERE WERE ',WIN6,' JACKPOT TICKET(S).');
WRITELN;
WRITELN ('THERE WERE ',LOSERS,' LOSERS.');
GOTOXY (10,20);
WRITE ('PRESS ANY KEY TO CONTINUE');
REPEAT UNTIL KEYPRESSED;
READ (KBD);
SCRNRESET;
END {PROC};

{
This procedure sorts the elements of a ticket into ascending order
}

PROCEDURE SORTPICK (VAR STKT:TKT);

VAR
   I, J, TEMP           : INTEGER;

BEGIN

FOR I := 1 TO (NUMPIC - 1) DO BEGIN
   FOR J := (I + 1) TO NUMPIC DO BEGIN
      IF (STKT[I] > STKT[J]) THEN BEGIN
         TEMP := STKT[I];
         STKT[I] := STKT[J];
         STKT[J] := TEMP;
      END {IF};
   END {DO};
END {DO};
END; {PROC}


{
This procedure generates a ticket using the random number generator.
Nupic number of pics are generated.  The ticket is sorted, and checked
for duplicates.  If no duplicates are found then the ticket is accepted.
Otherwise, a new number is issued for one of the duplicates and the new
ticket is retested.
}
PROCEDURE GENTKT (VAR RNDTKT:TKT);

VAR I,J,TEMP           :INTEGER;
    FAULT              :BOOLEAN;

BEGIN {PROC}

FOR I := 1 TO NUMPIC DO RNDTKT[I] := (RANDOM(MAXNUM)) + 1;
REPEAT
   SORTPICK (RNDTKT); {SORT THE ENTRYS}
   FAULT := FALSE;
   FOR I := 1 TO (NUMPIC - 1) DO BEGIN {CHECK FOR INVALID TICKET,
                              i.e. DUPLICATE PICK NUMBERS}
      J := I + 1;
      IF (RNDTKT[I] = RNDTKT[J]) THEN BEGIN {DUPLICATE FOUND}
        FAULT := TRUE; {SET FOR RECHECK}
        RNDTKT[J] := (RANDOM(MAXNUM)) + 1; {REPLACE WITH NEW PICK}
      END {IF}
   END; {DO}
UNTIL FAULT = FALSE;
END; {PROC}

{
This procedure generates a complete set of tickets for a simulation run.
The value of numtkts is used to determine the number of tickets to generate.
}


PROCEDURE SIMULATE;

VAR I : INTEGER;

BEGIN {PROC}
FOR I := 1 TO NUMTKTS DO GENTKT(TKTS[I]); {GENERATE NUMTKTS NUMBER OF RANDOM
                                            LOTTERY TICKETS}
GENTKT(WTKT); {GENERATE WINNING TICKET}
WINNERVALID := TRUE;
END; {PROC}


{
This procedure generates a screen display of the tickets including any valid
winning draw in the ticket data set.
}

PROCEDURE DISPTKTS;

VAR I, J, LINECOUNT, PCOUNT    :INTEGER;

BEGIN {PROC}

SCRNRESET;
IF WinnerValid = TRUE THEN BEGIN  {display the winning ticket}
   WRITELN ('THE WINNING TICKET IS:');
   I := 0;
   WRITE ('TKT NO. ',I:4,'::::');
   FOR J := 1 TO NUMPIC DO WRITE (WTKT[J]:6);
   WRITELN;
   WRITELN;
   WRITELN('YOUR TICKET PICKS ARE:');
   WRITELN;
   LINECOUNT := 7;
   END
ELSE
   LINECOUNT := 0
{ENDIF};
PCOUNT := 0;
FOR I := 1 TO NUMTKTS DO BEGIN           {print out the tickets}
   WRITE ('TKT NO. ',I:4,'::::');
   FOR J := 1 TO NUMPIC DO WRITE (TKTS[I,J]:6);
   WRITELN;
   PCOUNT := PCOUNT + 1;
   LINECOUNT := LINECOUNT + 1;
   IF ((PCOUNT MOD 5 = 0) AND (I < NUMTKTS)) THEN BEGIN {IF}
      WRITELN;
      PCOUNT := 0;
      LINECOUNT := LINECOUNT + 1;
      IF LINECOUNT > 18 THEN BEGIN {IF2} {screen full test}
         GOTOXY(1,25);
         HILITE;
         CLREOL;
         WRITE ('   ***  SCREEN FULL, PRESS ANY KEY TO CONTINUE   ***   ');
         REPEAT UNTIL KEYPRESSED; {WAIT FOR KEYSTROKE}
         READ (KBD);
         SCRNRESET;
         LINECOUNT := 0;
         END
      {END IF2};
      END
   {END IF};
END {DO};
GOTOXY(1,25);
HILITE;
CLREOL;
WRITE ('   ***   END OF ENTRIES, PRESS ANY KEY TO CONTINUE   ***   ');
REPEAT UNTIL KEYPRESSED; {WAIT FOR KEYSTROKE}
READ (KBD);
SCRNRESET;
END {PROC};


{
This procedure is used to build a ticket entry from the keyboard.
}

PROCEDURE BUILDTKT (VAR BTKT : TKT; VAR ABORT:BOOLEAN);

LABEL EXIT;

VAR
    I, ENTRY, J                             : INTEGER;
    DONE, DONE2, DONE3, DONE4               : BOOLEAN;
    ANSWER                                  : CHAR;

BEGIN
DONE := FALSE;
ABORT := FALSE;
REPEAT              {UNTIL VALID TICKET OR ABORT}
   FOR I := 1 TO NUMPIC DO BEGIN
      DONE2 := FALSE;
      REPEAT                 {UNTIL VALID ENTRY OR ABORT}
         GOTOXY(5,5);
         CLREOL;
         WRITE ('PICK NO.',I:2,' (0 TO QUIT)? ');
         ENTRY := -1; {SET DEFAULT}
         READLN (ENTRY);
         IOCHECKA;
         IF IOERR = TRUE THEN ENTRY := -1; {RESET DEFAULT ON I/O ERROR}
         CASE ENTRY OF           {TEST ENTRY}
         0           : BEGIN     {ABORT ENTRY}
                       ABORT := TRUE;
                       GOTO EXIT;
                       END;
         1..MAXNUM   : BEGIN     {VALID ENTRY}
                       DONE2 := TRUE;
                       BTKT[I] := ENTRY;
                       END;
         ELSE CHIRP
         END{CASE};
      UNTIL DONE2 = TRUE;
      GOTOXY (2,10);   {SELECT ECHO}
      CLREOL;
      WRITE ('YOU HAVE PICKED:');
      FOR J := 1 TO I DO WRITE (BTKT[J]:5);
      WRITELN;
   END{DO};
   SORTPICK (BTKT);           {SORT ENTRYS}
   DONE3 := TRUE;             {TEST FOR VALID TICKET}
   FOR I := 1 TO (NUMPIC - 1) DO BEGIN
      J := I + 1;
      IF BTKT[I] = BTKT[J] THEN DONE3 := FALSE;      {= MEANS INVALID TICKET}
   END{DO};
   DONE4 := TRUE;
   IF DONE3 = TRUE THEN BEGIN
      CLRSCR;
      GOTOXY (2,10); {ECHO BACK SORTED CHOICE}
      WRITE ('YOU HAVE PICKED:');
      FOR J := 1 TO NUMPIC DO WRITE (BTKT[J]:5);
      WRITELN;
      GOTOXY (2,15);   {PLACE PROMPT ON SCREEN}
      CLREOL;
      WRITE ('IS THIS CORRECT (Y/N)? ');
      REPEAT
         ANSWER := 'Z'; {SET DEFAULT}
         READ (KBD,ANSWER);
         IOCHECKA;
         IF IOERR = TRUE THEN ANSWER := 'Z'; {RESET DEFAULT ON I/O ERROR}
         ANSWER := UPCASE(ANSWER);
         IF (ANSWER IN ['Y','N']) = FALSE THEN BEEPBEEP(2);
      UNTIL ANSWER IN ['Y','N'];
      CLRSCR; {CLEAR ECHO AND PROMPT}
      IF ANSWER = 'N' THEN DONE4 := FALSE;
      END
   ELSE BEGIN
      GOTOXY(2,10);
      CLREOL;
      HILITE;
      WRITE ('   ***   INVALID NUMBER SELECTION, RETRY   ***   ');
      BEEPBEEP(3);
      DELAY(1500);
      LOLITE;
      GOTOXY(2,10);
      CLREOL;
      DONE4 := FALSE;
   END{IF};
   DONE := DONE2 AND DONE3 AND DONE4;
UNTIL DONE = TRUE;
EXIT : END{PROC};

{
This procedure will generate a random winning draw, or a manually entered
winning draw.  It will also erase the winning draw.
}


PROCEDURE BUILDWIN;

VAR BTKT        : TKT;
    ABORT       : BOOLEAN;
    I           : INTEGER;
    ANSWER      : CHAR;

BEGIN
SCRNRESET;
GOTOXY(1,3);
WRITE ('PRESS ');
HILITE;
WRITE ('A');
LOLITE;
WRITELN ('FOR ABORT.');
WRITE ('PRESS ');
HILITE;
WRITE ('R');
LOLITE;
WRITELN ('FOR RANDOM SELECTION OF WINNING DRAW.');
WRITE ('PRESS ');
HILITE;
WRITE ('E');
LOLITE;
WRITELN ('TO ENTER WINNING DRAW FROM KEYBOARD.');
WRITE ('PRESS ');
HILITE;
WRITE ('W');
LOLITE;
WRITELN ('TO ERASE WINNING DRAW.');
GOTOXY(1,10);
WRITE ('ENTER YOUR CHOICE (A,R,E,W)? ');
REPEAT
   ANSWER := 'Z'; {SET DEFAULT}
   READ (KBD,ANSWER);
   IOCHECKA;
   IF IOERR = TRUE THEN ANSWER := 'Z'; {RESET DEFAULT ON I/O ERROR}
   ANSWER := UPCASE (ANSWER);
   IF (ANSWER IN ['A','R','E','W']) = FALSE THEN BEEP;
UNTIL ANSWER IN ['A','R','E','W'];
WRITELN (ANSWER);  {ECHO ACCEPTED ANSWER}
DELAY(500); {LET THE USER SEE IT}
CASE ANSWER OF
'R' : BEGIN
         GENTKT(WTKT);
         WINNERVALID := TRUE;
      END;
'E' : BEGIN
         SCRNRESET;
         BUILDTKT(BTKT,ABORT);
         IF ABORT = FALSE THEN BEGIN
            WTKT := BTKT;
            WINNERVALID := TRUE;
         END{IF};
      END;
'W' : BEGIN
         FOR I := 1 TO NUMPIC DO WTKT[I] := MAXNUM; {FILL WITH NULL PATTERN}
         WINNERVALID := FALSE;
      END;
END{CASE};
END{PROC};


{
This procedure is called from the main menu to build a series of tickets from
the keyboard.  It calls BUILDTKT repeatedly.
}

PROCEDURE ADDTKTS;

VAR BTKT         : TKT;
    ABORT        : BOOLEAN;
    GOMAX        : INTEGER;

BEGIN
SCRNRESET;
REPEAT
   GOMAX := TKTMAX - NUMTKTS;
   GOTOXY (2,2);
   CLREOL;
   WRITE ('YOU MAY ENTER UP TO',GOMAX:4,' ADDITIONAL ENTRIES.');
   BUILDTKT(BTKT,ABORT);
   IF ABORT = FALSE THEN BEGIN
      NUMTKTS := NUMTKTS + 1;
      TKTS[NUMTKTS] := BTKT;
   END{IF};
UNTIL ((ABORT = TRUE) OR (NUMTKTS >= TKTMAX))
END{PROC};


{
This procedure will add a number of random tickets to the data set based on
input from the keyboard.  Procedure GENTKT is called to generate each ticket.
}

PROCEDURE ADDRANDUM;

VAR MAXGO, KOUNT, I           : INTEGER;
    RNDTKT                    : TKT;
    DONE                      : BOOLEAN;

BEGIN
MAXGO := TKTMAX - NUMTKTS;
SCRNRESET;
GOTOXY (5,2);
WRITELN ('YOU MAY REQUEST UP TO',MAXGO:4,' TICKETS.');
DONE := FALSE;
REPEAT
   GOTOXY (5,5);
   CLREOL;
   WRITE ('HOW MANY TICKETS? ');
   KOUNT := -1; {SET DEFAULT}
   READLN (KOUNT);
   IOCHECKA;
   IF IOERR = TRUE THEN KOUNT := -1; {RESET DEFAULT ON I/O ERROR}
   IF KOUNT = 0 THEN DONE:=TRUE;                     {ABORT}
   IF ((KOUNT > 0) AND (KOUNT <= MAXGO)) THEN BEGIN  {VALID INPUT}
      FOR I := 1 TO KOUNT DO BEGIN                   {BUILD THE TICKETS LOOP}
         GENTKT(RNDTKT);                             {BUILD SINGLE TICKET}
         NUMTKTS := NUMTKTS + 1;
         TKTS[NUMTKTS] := RNDTKT;
      END{DO};
      DONE := TRUE;        {FINISHED WITH TASK}
      END
   ELSE BEEP {INVALID OR DEFAULT REPLY}
   {ENDIF};
UNTIL DONE = TRUE;
END{PROC};


{
This procedure removes a ticket from the ticket set.
}

PROCEDURE DROPTKTS;

VAR
   ANSWER              : CHAR;
   I, J, K             : INTEGER;

BEGIN
SCRNRESET;

                    {RED ON WHITE TOP BANNER}

TEXTCOLOR (RED);
TEXTBACKGROUND (WHITE);
CLREOL;
WRITELN;
CLREOL;
WRITELN ('   !!!   WARNING   !!!  REMAINDER OF SET WILL BE RENUMBERED!');
CLREOL;

                    {RETURN TO NORMAL}

LOLITE;
REPEAT
   GOTOXY (5,9);
   CLREOL;
   WRITE ('DO YOU WISH TO PROCEDE (Y/N)? ');
   ANSWER := 'Z'; {SET DEFAULT INVALID ANSWER}
   READ (KBD,ANSWER);
   IOCHECKA;
   IF IOERR = TRUE THEN ANSWER := 'Z'; {RESET DEFAULT ON I/O ERROR}
   ANSWER := UPCASE(ANSWER);
   IF NOT(ANSWER IN ['Y','N']) THEN BEEPBEEP(2);
UNTIL ANSWER IN ['Y','N'];
WRITE (ANSWER); {ECHO ACCEPTED ANSWER}
IF ANSWER = 'Y' THEN BEGIN
   GOTOXY (5,12);
   WRITELN ('THERE ARE',NUMTKTS:4,' TICKETS IN THE SET.');
   REPEAT
      GOTOXY (2,15);
      CLREOL;
      WRITE ('TICKET NUMBER TO BE DELETED? ');
      I := NUMTKTS + 1; {SET DEFAULT}
      READLN (I);
      IOCHECKA;
      IF IOERR = TRUE THEN I:= NUMTKTS + 1; {RESET DEFAULT ON I/O ERROR}
      IF NOT(I IN [1..NUMTKTS]) THEN BEEP;
   UNTIL I IN [1..NUMTKTS];      {VALID INPUT TEST}
   IF I <> NUMTKTS THEN BEGIN                {DROP THE STACK}
      FOR J := I TO (NUMTKTS - 1) DO BEGIN
         K := J + 1;
         TKTS[J] := TKTS[K];
      END{DO};
   END{IF};
   FOR J := 1 TO NUMPIC DO TKTS[NUMTKTS,J] := MAXNUM; {ERASE TOP OF STACK}
   NUMTKTS := NUMTKTS - 1; {DECREASE TOP OF DATA POINTER}
END{IF};
SCRNRESET;
END{PROC};


{
THIS PROCEDURE INSERTS A TICKET INTO THE SET
}

PROCEDURE INSERTTKT;

LABEL
    EXIT;

VAR
    DONE, ABORT                          : BOOLEAN;
    INSRTPOINT, OLDTOP, I                : INTEGER;
    BTKT                                 : TKT;

BEGIN
DONE := FALSE;
REPEAT
  SCRNRESET;
  WRITELN;
  WRITELN ('ENTER TICKET NUMBER FROM 1 TO ',NUMTKTS);
  WRITE (' OR ENTER 0 TO EXIT.   ');
  INSRTPOINT := -1; {SET DEFAULT INVALID VALUE}
  READLN (INSRTPOINT);
  IOCHECKA;
  IF IOERR = TRUE THEN INSRTPOINT := -1; {RESET TO DEFAULT VALUE}
  IF (INSRTPOINT IN [0..NUMTKTS]) THEN
    DONE := TRUE
  ELSE BEGIN
    ALERT1 (1);
    DELAY (1000);
  END {IF};
UNTIL DONE = TRUE;
IF INSRTPOINT = 0 THEN GOTO EXIT;
BUILDTKT (BTKT,ABORT);
IF ABORT = FALSE THEN BEGIN
  OLDTOP := NUMTKTS;
  NUMTKTS := NUMTKTS + 1;
  FOR I:= OLDTOP DOWNTO INSRTPOINT DO BEGIN
    TKTS[I+1] := TKTS[I];
  END;
  TKTS[INSRTPOINT] := BTKT
END {IF};
EXIT:
END {PROC};


{
THIS PROCEDURE REPLACES ONE TICKET IN THE SET WITH ANOTHER ENTERED FROM THE
KEYBOARD.
}

PROCEDURE REPLACETKTS;

LABEL
    LOOP;

VAR
    SELECT                              : INTEGER;
    DONE, ABORT                         : BOOLEAN;
    BTKT                                : TKT;

BEGIN
DONE := FALSE;
REPEAT
  SCRNRESET;
  WRITELN;
  WRITELN ('ENTER TICKET NO. FROM 1 TO ',NUMTKTS);
  WRITE   (' OR ENTER 0 TO ABORT.   ');
  SELECT := -1; {SET DEFAULT VALUE}
  BEEP;
  READLN (SELECT);
  IOCHECKA;
  IF IOERR = TRUE THEN BEGIN
    ALERT1 (1);
    DELAY (1000);
    GOTO LOOP;
  END {IF};
  IF SELECT = 0 THEN BEGIN
    DONE := TRUE;
    GOTO LOOP;
  END {IF};
  IF ((SELECT >= 1) AND (SELECT <= NUMTKTS)) THEN BEGIN
    BUILDTKT(BTKT,ABORT);
    IF ABORT = FALSE THEN TKTS[SELECT] := BTKT;
    DONE := TRUE; END
  ELSE BEGIN
    ALERT1 (1);
    DELAY (1000);
  END {IF};
LOOP:
UNTIL DONE = TRUE;
END {PROC};


{
THIS PROCEDURE DISPLAYS THE EDIT MENU AND EXECUTES THE APPROPRIATE SUBROUTINES
TO EDIT EXISTING ENTRIES.
}

PROCEDURE EDITMENU;

LABEL
    EXIT, LOOP;

VAR
    DONE                                  : BOOLEAN;
    SELECTION                             : INTEGER;

BEGIN
DONE := FALSE;
REPEAT
  SCRNRESET;
  IF NUMTKTS < 1 THEN GOTO EXIT;
  GOTOXY (35,2);
  WRITELN ('EDIT MENU');
  WRITELN ;
  WRITELN ('0.  EXIT THIS MENU.');
  IF NUMTKTS < TKTMAX THEN
    WRITELN ('1.  INSET TICKET INTO SET.')
  ELSE
    WRITELN
  {END IF};
  WRITELN ('2.  DELETE TICKET FROM SET.');
  WRITELN ('3.  REPLACE TICKET IN SET.');
  WRITELN;
  WRITE ('ENTER YOUR SELECTION.  ');
  SELECTION := -1; {SET DEFAULT INVALID}
  BEEP;
  READLN (SELECTION);
  IOCHECKA;
  IF IOERR = TRUE THEN SELECTION := -1; {RESTORE DEFAULT VALUE}
  IF NOT(SELECTION IN [0..3]) THEN BEGIN
    GOTOXY (1,22);
    WRITE ('ERROR TRY AGAIN');
    HILOTONE(2);
    DELAY (1000);
    GOTO LOOP;
  END {IF};
  CASE SELECTION OF
  0 : DONE := TRUE;
  1 : BEGIN
        INSERTTKT;
        IF AUTODISP = Y THEN DISPTKTS;
      END;
  2 : BEGIN
        DROPTKTS;
        IF AUTODISP = Y THEN DISPTKTS;
      END;
  3 : BEGIN
        REPLACETKTS;
        IF AUTODISP = Y THEN DISPTKTS;
      END;
  END {CASE};
LOOP :
UNTIL DONE = TRUE;
EXIT :
END {PROC};


{opening display, copyright notice and music}

PROCEDURE BANNER;

BEGIN
HILITE;
ClrScr;
GoToXY (28,5);
WRITELN ('***   LOTTERY FUN   ***');
GoToXY (31,8);
WRITELN ('BY KARL W. EHRLICH');
GOTOXY (1,14);
LOLITE;
WRITELN ('  COPYRIGHT (c) AUGUST 1986     ');
WRITELN ('           AND OCTOBER 1986     ');
WRITELN ('                                ');
WRITELN ('  ALL RIGHTS RESERVED           ');
HILITE;
WRITELN;
WRITELN ('RELEASE NUMBER: ',RELNO:6:3);
HILOTONE (3);
DELAY (5000);
END;


{
This procedure take an input file name and verifies that it is either a
standard file name, or a drive:filename without an extension.  If the
file name is valid the extension .lfd is added and fault is set to false.

In case of error fault is set to true and the original name is unchanged.
}


PROCEDURE VFNAME (VAR FILEB : FILENAME; VAR FAULT : BOOLEAN);

VAR
    FILEA                          : FILENAME;
    I                              : INTEGER;

BEGIN
FILEA := FILEB;
FAULT := FALSE;

{CONVERT TO UPPER CASE LETTERS}

FOR I := 1 TO LENGTH(FILEA) DO FILEA[I] := UPCASE (FILEA[I]);

{STRIP LEADING BLANKS}

WHILE ((LENGTH (FILEA) > 0) AND (FILEA[1] = ' ')) DO DELETE (FILEA,1,1);

{STRIP TRAILING BLANKS}

WHILE ((LENGTH (FILEA) > 0) AND (FILEA[LENGTH (FILEA)] = ' ')) DO
     DELETE (FILEA, (LENGTH (FILEA)), 1);

{CHECK FOR VALID REMAINING CHARACTERS BASED ON LENGTH}

CASE LENGTH (FILEA) OF
0     : FAULT := TRUE;
9,10  : BEGIN {BRANCH}
        IF ((FILEA[1] IN ['A'..'F']) AND (FILEA[2] = ':')) THEN BEGIN
          IF NOT (FILEA[3] IN ['A'..'Z']) THEN FAULT := TRUE
          ELSE BEGIN
            FOR I := 3 TO LENGTH (FILEA) DO BEGIN
              IF NOT (FILEA[I] IN ['A'..'Z','0'..'9']) THEN FAULT := TRUE;
            END {DO};
          END {IF};
          END
        ELSE FAULT := TRUE
        {END IF};
        END {BRANCH};
1..8  : BEGIN {BRANCH}
        IF ((FILEA[1] IN ['A'..'F']) AND (FILEA[2] = ':') AND
             (LENGTH (FILEA) > 2)) THEN BEGIN
          IF NOT (FILEA[3] IN ['A'..'Z']) THEN FAULT := TRUE
          ELSE BEGIN
            FOR I := 3 TO LENGTH (FILEA) DO BEGIN
              IF NOT (FILEA[I] IN ['A'..'Z','0'..'9']) THEN FAULT := TRUE;
            END {DO};
          END {IF};
          END
        ELSE BEGIN
          IF NOT (FILEA[1] IN ['A'..'Z']) THEN FAULT := TRUE
          ELSE BEGIN
            FOR I := 1 TO LENGTH (FILEA) DO BEGIN
              IF NOT (FILEA[I] IN ['A'..'Z','0'..'9']) THEN FAULT := TRUE;
            END {DO};
          END {IF};
        END {IF};
        END {BRANCH};
ELSE    FAULT := TRUE
END {CASE};
IF FAULT = FALSE THEN FILEB := FILEA + '.LFD';
END {PROC};


{THIS PROCEDURE RENAMES A FILE FOR DATA.}

PROCEDURE RENFILE;

LABEL
     EXIT;

VAR
     FOUND1, FOUND2, FAULT                  : BOOLEAN;
     FILE1, FILE11, FILE2, FILE21           : FILENAME;
     OLDFILE, NEWFILE                       : TEXT;
     IOVAR, IOVAR2                          : INTEGER;
BEGIN
SCRNRESET;
GOTOXY (1,6);
WRITELN ('OR PRESS RETURN TO EXIT');
REPEAT
  GOTOXY (1,4);
  CLREOL;
  WRITE ('NAME OF FILE TO BE RENAMED? ');
  READLN (FILE1);
  IOCHECKA;
  IF IOERR = TRUE THEN FAULT := TRUE
  ELSE BEGIN
    IF FILE1 = '' THEN GOTO EXIT;
    FILE11 := FILE1;
    VFNAME (FILE11, FAULT);
  END{IF};
UNTIL FAULT = FALSE;
GOTOXY (1,12);
WRITELN ('OR PRESS RETURN TO EXIT');
REPEAT
  GOTOXY (1,10);
  CLREOL;
  WRITE ('NEW FILE NAME? ');
  READLN (FILE2);
  IOCHECKA;
  IF IOERR = TRUE THEN FAULT := TRUE
  ELSE BEGIN
    IF FILE2 = '' THEN GOTO EXIT;
    FILE21 := FILE2;
    VFNAME (FILE21, FAULT);
  END{IF};
UNTIL FAULT = FALSE;
ASSIGN (OLDFILE,FILE11);
RESET (OLDFILE) {CHECK TO SEE FILE EXISTS.};
IOVAR := IORESULT;
IF IOVAR = 0 THEN BEGIN {FILE FOUND}
  CLOSE (OLDFILE);
  ASSIGN (NEWFILE, FILE21);
  RESET (NEWFILE) {CHECK TO SEE THAT FILE DOESN'T EXIST};
  IOVAR2 := IORESULT;
  IF IOVAR2 IN [$01,$02] THEN BEGIN
    RENAME (OLDFILE, FILE21);
    IOCHECK;
    IF IOERR = TRUE THEN BEGIN
      WRITELN ('RENAME ABORTED',^G);
      DELAY (1000);
      GOTO EXIT;
    END{IF};
    END
  ELSE BEGIN
    GOTOXY (1,20);
    IF IOVAR2 = 0 THEN WRITELN ('FILE > ',FILE2,' < ALREADY EXISTS')
    ELSE WRITELN ('I/O ERROR WITH > ',FILE2,' <',IOVAR2:10)
    {ENDIF};
    WRITELN ('RENAME ABORTED',^G);
    DELAY (1000);
    GOTO EXIT;
  END{IF};
  END
ELSE BEGIN {FILE NOT FOUND}
  GOTOXY (1,20);
  IF IOVAR IN [1,2] THEN WRITELN ('FILE > ',FILE1,' < NOT FOUND')
  ELSE WRITELN ('I/O ERROR WITH > ',FILE1,' <',IOVAR:10)
  {ENDIF};
  WRITELN ('RENAME ABORTED',^G);
  DELAY (1000);
END{IF};
EXIT:
END {PROC};


{
This procedure requests a data file name for deletion.  Data files all have
the extension .LFD.  The operator only puts in the file name.  The file name
is checked for proper input I/O and then to see if it fits the format of name
or X:name.  If the file name passes these checks an attempt is made to erase
the file and an I/O check is performed.
}

PROCEDURE DROPFILE;

LABEL
     EXIT;

VAR
     FILEA                          : FILENAME;
     FAULT                          : BOOLEAN;
     ERASEFILE                      : TEXT;

BEGIN
SCRNRESET;
GOTOXY (1,7);
WRITELN ('OR PRESS RETURN TO EXIT');
REPEAT {ENTER FILE NAME}
   GOTOXY (1,5);
   CLREOL;
   WRITE ('NAME OF DATA FILE TO BE ERASED? ');
   READLN (FILEA);
   IOCHECKA;
   IF IOERR = TRUE THEN FAULT := TRUE {bad input, cause a retry}
   ELSE BEGIN
     IF FILEA = '' THEN GOTO EXIT; {test for abort}
     VFNAME (FILEA, FAULT); {verify file name and append suffix if valid
                             else cause a retry}
   END{IF};
UNTIL FAULT = FALSE;
ASSIGN (ERASEFILE, FILEA);   {try to locate the file}
ERASE (ERASEFILE);         {erase the file}
IOCHECK;
EXIT :
END {PROC};


{
THIS PROCEDURE READS IN THE TICKET DATA FROM A DISK DATA FILE.
}

PROCEDURE RDISKTKTS;

LABEL
     PEXIT;

TYPE
     FILENAME = STRING[32];


VAR
     I, IOVAL                               : INTEGER;
     FOUND, FAULT                           : BOOLEAN;
     FILEA                                  : FILENAME;

BEGIN
SCRNRESET;
FOUND := FALSE;
GOTOXY (1,3);
WRITELN;
WRITELN ('OR PRESS RETURN TO EXIT.');
WRITELN;
WRITELN ('WARNING!  CURRENT TICKET SET WILL BE LOST!');
REPEAT {UNTIL IO GOOD}
   GOTOXY (1,2);
   CLREOL;
   WRITE ('NAME OF FILE TO READ? ');
   READLN (FILEA);
   IOCHECKA;
   IF IOERR = TRUE THEN FAULT := TRUE
   ELSE BEGIN
      IF FILEA = '' THEN GOTO PEXIT;
      VFNAME (FILEA, FAULT);
   END {IF};
UNTIL FAULT = FALSE;
ASSIGN (INFILE,FILEA);
RESET (INFILE);
IOCHECK;
IF IOERR = TRUE THEN GOTO PEXIT;
FOUND := TRUE;
REINIT;   {CLEAR AWAY OLD TICKETS}
SEEK (INFILE,0);  {ASSURE STARTING POSITION}
READ (INFILE,TKTREC);
IOCHECK;
IF IOERR = TRUE THEN GOTO PEXIT; {BOMB & OUT}
WTKT := TKTREC.TICKET;
IF WTKT[1] < MAXNUM THEN WINNERVALID := TRUE;
WHILE NOT(EOF(INFILE)) DO BEGIN
   READ (INFILE,TKTREC); {READ IN A TICKET VALUE}
   IOCHECK;
   IF IOERR = TRUE THEN GOTO PEXIT; {BOMB & OUT}
   NUMTKTS := NUMTKTS + 1;
   IF NUMTKTS > TKTMAX THEN GOTO PEXIT; {FILE TOO LARGE}
   TKTS[NUMTKTS] := TKTREC.TICKET;  {STORE IN THE ARRAY}
END{WHILE};
PEXIT : IF FOUND = TRUE THEN CLOSE(INFILE);  {HOUSEKEEPING SHUTDOWN FILE}
END {PROC};


{
THIS PROCEDURE WRITES TICKET DATA TO DISK.  ONLY DATA FOR VALID TICKETS
AND THE WINNER ARE WRITTEN TO THE DISK.
}

PROCEDURE WDiskTkts;

LABEL
    EXIT;

TYPE
    FILENAME = STRING[32];

VAR I, Ioval1                           : INTEGER;
    Found, Open, IOErr1, FAULT          : BOOLEAN;
    CH                                  : CHAR;
    FILEA                               : FILENAME;

BEGIN
SCRNRESET;
Found := FALSE;
GOTOXY (1,3);
WRITELN ('OR PRESS RETURN TO EXIT');
REPEAT {UNTIL FILE TO WRITE OR ABORT}
   GOTOXY (1,2);
   CLREOL;
   WRITE ('NAME OF FILE TO WRITE? ');
   READLN (FileA);
   IOCHECKA;
   IF IOERR = TRUE THEN FAULT := TRUE  {BAD INPUT}
   ELSE BEGIN
      IF FILEA = '' THEN GOTO EXIT;    {ABORT CHECK}
      VFNAME (FILEA, FAULT);           {VERIFY FILE NAME OR FAULT:=TRUE}
   END {IF};
UNTIL FAULT = FALSE; {VALID INPUT TEST}
ASSIGN (OutFile,FileA);
RESET (OutFile); {TEST FOR FILE FOUND BY OPENING FOR READ}
IOCHECKA;
IF IOERR = FALSE THEN BEGIN {FILE FOUND}
   CLOSE (OutFile);     {CLOSE IT SO IT CAN BE REOPENED FOR WRITITNG}
   GOTOXY (1,6); {ALERT & PROMPT}
   HILITE;
   WRITELN ('FILE> ',FileA,' ALREADY EXISTS.');
   WRITELN;
   WRITE (' !!! WARNING !!!  ');
   WRITELN ('OVERWRITE WILL WIPE OUT WHATEVER IS IN THE FILE!');
   WRITELN;
   REPEAT          {HUMAN DECISION REQUIRED}
      GOTOXY (1,12);
      CLREOL;
      WRITE ('OVERWRITE (Y/N)? ');
      BEEPBEEP (3);
      CH := 'A'; {SET DEFAULT FOR RECYCLE}
      READ (KBD,CH);
      IOCHECKA;
      IF IOERR = TRUE THEN CH := 'A'; {RESET DEFAULT ON I/O FILE ERROR}
      CH := UPCASE(CH);
   UNTIL CH IN ['Y','N'];
   WRITELN (CH); {ECHO}
   DELAY (500);              {SHOW THE CHOICE}
   IF CH = 'N' THEN GOTO EXIT;
   END
ELSE BEGIN     {FILE NOT SUCCESSFULLY FOUND}
   IF Ioval > $02 THEN BEGIN {PROBLEM OTHER THAN FILE NOT FOUND}
      HILITE;
      GOTOXY (1,9);
      WRITELN ('I/O ERROR NO. ',Ioval1,' HAS OCCURRED');
      WRITE (^G);
      REPEAT UNTIL KEYPRESSED;
      READ (KBD);
      GOTO EXIT;
   END{IF};
END{IF};
ASSIGN (OUTFILE,FILEA);
REWRITE (OutFile);
IOCheck;
IF IOERR = TRUE THEN GOTO EXIT;
Open := TRUE;
SEEK (OutFile,0); {ASSURE FIRST RECORD}
IOCheck;
IF IOERR = TRUE THEN GOTO EXIT;  {BOMB & OUT}
TKTREC.TICKET := WTKT;
WRITE (OutFile,TKTREC);
IOCheck;
IF IOERR = TRUE THEN GOTO EXIT;  {BOMB & OUT}
FOR I := 1 TO NUMTKTS DO BEGIN
   TKTREC.TICKET := TKTS[I];
   WRITE (OutFile,TKTREC);
   IOCheck;
   IF IOERR = TRUE THEN GOTO EXIT;  {BOMB & OUT}
END{DO};
EXIT : IF Open = TRUE THEN CLOSE(OutFile);
END{PROC};


{
THIS PROCEDURE PRINTS OUT THE TICKET SET WITH APPROPRIATE PAUSE LOGIC
}

Procedure PrintTickets;

CONST Space=' ';

Var StartTktNo, EndTktNo, TktsRem, PrintCount, GroupCount,
    ColGroups, I, J, K, LCount                             : INTEGER;

    LastPage                                               : Boolean;

BEGIN
HILITE;
CLRSCR;
WRITELN ('SET PRINTER TO TOP OF FORM AND ON LINE,');
WRITELN;
WRITELN ('THEN PRESS ANY KEY TO CONTINUE PRINTING.');
BEEPBEEP (3);
REPEAT UNTIL KEYPRESSED;
READ (KBD);
StartTktNo := 1;
TktsRem := NumTkts;
LastPage := TRUE;
WHILE TktsRem > 0 do BEGIN
   IF TktsRem > 80 THEN BEGIN
      PrintCount := 40;
      EndTktNo := StartTktNo + 79;
      LastPage := FALSE;
      END
   ELSE BEGIN
      GroupCount := TktsRem DIV 5;
      IF (TktsRem MOD 5) > 0 THEN GroupCount := GroupCount +1;
      ColGroups := (GroupCount DIV 2) + (GroupCount MOD 2);
      PrintCount := ColGroups * 5;
      EndTktNo := NUMTKTS;
      LastPage := TRUE;
   END {IF};
   FOR I := 1 TO 6 DO WRITELN (LST);
   FOR I := 1 TO 33 DO WRITE (LST,Space);
   WRITELN (LST,'TICKETS PICKED');
   WRITELN (LST);
   WRITE (LST,'TICKET     NUMBERS');
   FOR I := 1 TO 23 DO WRITE (LST,Space);
   WRITELN (LST,'TICKET     NUMBERS');
   WRITE (LST,'NUMBER      PICKED');
   FOR I := 1 TO 23 DO WRITE (LST,Space);
   WRITELN (LST,'NUMBER      PICKED');
   WRITELN (LST);
   LCount := 0;
   FOR I:= StartTktNo TO (StartTktNo + PrintCount - 1) DO BEGIN
      J := I + PrintCount;
      WRITE (LST,I:3);
      WRITE (LST,TKTS[I,1]:8);
      FOR K := 2 TO Numpic DO WRITE (LST,TKTS[I,K]:4);
      IF J > NumTkts THEN WRITELN(LST)
      ELSE BEGIN
         WRITE (LST,J:13);
         WRITE (LST,TKTS[J,1]:8);
         FOR K := 2 TO Numpic DO WRITE (LST,TKTS[J,K]:4);
         WRITELN (LST);
      END{IF};
      LCount := LCount + 1;
      IF ((LCount +1) MOD 6) = 0 THEN BEGIN
         WRITELN (LST);
         LCount := LCount + 1;
      END{IF};
   END{DO};
   IF LastPage = FALSE THEN BEGIN
      WRITE (LST,^L);      {TOP OF PAGE}
      StartTktNo := EndTktNo + 1;
      TktsRem := NumTkts - EndTktNo;
      END
   ELSE BEGIN
      TktsRem := 0;
   END{IF};
END{WHILE};
IF WINNERVALID = TRUE THEN BEGIN
   IF LCount > 43 THEN BEGIN     {CHECK FOR ENOUGH PAGE REMAINING}
      WRITE (LST,^L);  {EJECT PAGE}
      FOR I := 1 TO 6 DO WRITELN (LST);
      WRITELN;
   END{IF};
   WRITELN (LST);
   WRITELN (LST);
   FOR I := 1 TO 24 DO WRITE (LST,Space);
   WRITELN (LST,'THE WINNING LOTTO NUMBERS WERE:');
   WRITELN (LST);
   FOR I := 1 TO 24 DO WRITE (LST,Space);
   FOR I := 1 TO Numpic DO WRITE (LST,WTKT[I]:4);
END{IF};
WRITE (LST,^L); {EJECT PAGE}
END{PROC};


{
THIS PROCEDURE ACTS AS THE MAIN MENU AND TASK SCHEDULER FOR THE LOTTERY
PROGRAM.  IT SCHEDULES ALL EXECUTION EXCEPT FOR PROGRAM INITIALIZATION AND
TERMINATION.
}

PROCEDURE MAINMENU;

LABEL
      ENDLOOP;

CONST
      MAXCHOICE = 15;
      QUESTLINE = 19;

TYPE
      CHOICETYPE = 0..MAXCHOICE;
      CHOICESET = SET OF 0..MAXCHOICE;
VAR
      DONE                                               : BOOLEAN;
      REPLYVALID                                         : CHOICESET;
      SELECTION                                          : CHOICETYPE;

BEGIN
DONE := FALSE;
REPEAT

     { This procedure generates the main selection menu for the program.}

   SCRNRESET;
   REPLYVALID := [0..2,7,11..15];
   HILITE;
   GoToXY (35,2);
   WRITELN ('MAIN MENU');
   WINDOW (3,4,78,23);
   ClrScr;
   WRITELN;
   WRITELN (' 0.  EXIT PROGRAM');
   WRITELN (' 1.  READ TICKET SET FROM DISK');
   WRITELN (' 2.  START NEW TICKET SET');
   IF (NUMTKTS < TKTMAX) THEN BEGIN
      REPLYVALID := REPLYVALID + [3,4];
      WRITELN (' 3.  ENTER MORE TICKETS INTO SET');
      WRITELN (' 4.  ADD RANDOM PICKS TO SET');END
   ELSE BEGIN
      WRITELN; WRITELN;
   END{IF};
   IF NUMTKTS > 0 THEN BEGIN
      REPLYVALID := REPLYVALID + [5,6];
      WRITELN (' 5.  EDIT TICKETS IN SET');
      WRITELN (' 6.  STORE TICKET SET TO DISK');END
   ELSE BEGIN
      WRITELN; WRITELN;
   END{IF};
   WRITELN (' 7.  ENTER WINNING TICKET DRAWN');
   IF ((NUMTKTS > 0) AND (WINNERVALID = TRUE)) THEN BEGIN
      REPLYVALID := REPLYVALID + [8];
      WRITELN (' 8.  SCAN TICKET SET FOR WINNERS');END
   ELSE BEGIN
      WRITELN;
   END{IF};
   IF ((NUMTKTS > 0) OR (WINNERVALID = TRUE)) THEN BEGIN
      REPLYVALID := REPLYVALID + [9,10];
      WRITELN (' 9.  PRINT TICKET SET');
      WRITELN ('10.  DISPLAY TICKET SET');END
   ELSE BEGIN
      WRITELN; WRITELN;
   END{IF};
   WRITELN ('11.  RUN SIMULATION');
   WRITELN ('12.  OPTIONS MENU');
   WRITELN ('13.  DATA FILE DIRECTORY');
   WRITELN ('14.  ERASE DATA FILE');
   WRITELN ('15.  RENAME DATA FILE');

            {GET USER SELECTION AND TEST FOR VALIDITY}

   REPEAT
      GoToXY (15,QUESTLINE);
      CLREOL;
      WRITE ('ENTER YOUR SELECTION      ');
      SELECTION := -1; {ENTER DEFAULT}
      READLN (SELECTION);
      IOCheckA;
      IF IOERR = TRUE THEN SELECTION := -1; {RESET AS INVALID ANSWER}
      IF NOT(SELECTION IN REPLYVALID) THEN BEGIN
         GoToXY (1,QUESTLINE);
         CLREOL;
         GoToXY (10,QUESTLINE);
         WRITE ('ERROR !!! - ILLEGAL CHOICE, TRY AGAIN');
         ALERT1 (1);
         DELAY (1000);
         GoToXY (1,QUESTLINE);
         CLREOL;
         GOTO ENDLOOP;
      END{IF};
   UNTIL SELECTION IN REPLYVALID;

                       {PROCESS VALID RESPONSE}

   CASE SELECTION OF
    0 :   DONE:=TRUE;
    1 :   BEGIN
             RDISKTKTS;
             IF AUTODISP = Y THEN DISPTKTS;
             IF AUTOPRINT = Y THEN PRINTTICKETS;
          END;
    2 :   REINIT;
    3 :   ADDTKTS;
    4 :   BEGIN
             RANDOMIZE (0,0);
             ADDRANDUM;
             IF AUTODISP = Y THEN DISPTKTS;
          END;
    5 :   EDITMENU;
    6 :   WDISKTKTS;
    7 :   BUILDWIN;
    8 :   SCANTKTS;
    9 :   PRINTTICKETS;
   10 :   DISPTKTS;
   11 :   BEGIN
             REINIT;
             NUMTKTS := TKTMAX;
             SIMULATE;
             SCANTKTS;
             IF AUTODISP = Y THEN DISPTKTS;
          END;
   12 :   OPTMENU;
   13 :   DISPDIR;
   14 :   DROPFILE;
   15 :   RENFILE;
   END{CASE};
ENDLOOP :
UNTIL DONE = TRUE;
END {PROC};

      {  MAIN PROGRAM BEGINS HERE ...... MAIN PROGRAM BEGINS HERE  }


BEGIN {LOTTERY}

                               {INITIALIZE}

RANDOMIZE(0,0);
NOSOUND; {SET UP THE SOUND EFFECTS GENERATOR}
REINIT;  {ZERO OUT THE DATA ARRAYS}

{SET KEYBOARD TO CAPS LOCK AND NUM LOCK ON
THIS IS DONE BY SETTING BITS 6 & 5 OF MEMORY LOCATION 00417H TO 1.}

STARTBYTE := MEM[$0000:$0417]; {GET STARTING CONDITION OF KBD}
POKEBYTE := STARTBYTE OR $60; {SET BITS 6 & 5}
MEM[$0000:$0417] := POKEBYTE; {POKE BACK INTO MEMORY}

{SET INITIAL OPTIONS}

PWPRINT := N;
PWDISP := Y;
AUTODISP := N;
AUTOPRINT := N;

                             {RUN MAIN PROGRAM}

BANNER; {PRINT OUT A GREETING}

MAINMENU; {MAIN DRIVER MENU}

                            {PROGRAM TERMINATION}

WINDOW (1,1,80,25);
HILITE;
ClrScr;
GoToXY (35,13);
WRITELN ('GOOD BYE!');

{RETURN KEYBOARD TO ORIGINAL CONDITION}

OLDCON := STARTBYTE AND $60; {GET ORIGINAL BITS 6 & 5}
NOWBYTE := MEM[$0000:$0417]; {GET CURRENT BYTE}
POKEBYTE := (NOWBYTE AND NOT($60)) OR OLDCON; {MASK OUT BITS 6 & 5 THEN OR IN
                                               THE OLD VALUES}
MEM[$0000:$0417] := POKEBYTE; {POKE VALUE BACK INTO MEMORY}
BEEPBEEP(3);
END.